home *** CD-ROM | disk | FTP | other *** search
/ Compendium Deluxe 2 / LSD and 17bit Compendium Deluxe - Volume II.iso / a / prog / cprog / f2c3.2bin.lha / f2c-for-SASC651 / fsplit.lha / fsplit / fsplit.rat < prev    next >
Encoding:
Text File  |  1994-07-08  |  7.3 KB  |  315 lines
  1. #  fsplit.rat - the program proper. This file is part of FSPLIT.
  2. #
  3. #    Copyright (C) 1994 Torsten Poulin
  4. #    Email: torsten@diku.dk
  5. #    Version of 25-JUL-94
  6. #
  7. #  Redistribution and use in source and binary forms, with or without
  8. #  modification, are permitted provided that the following conditions
  9. #  are met:
  10. #
  11. #  1. Redistributions of source code must retain the above copyright
  12. #     notice, this list of conditions and the following disclaimer.
  13. #  2. Redistributions in binary form must reproduce the above copyright
  14. #     notice, this list of conditions and the following disclaimer in the
  15. #     documentation and/or other materials provided with the distribution.
  16. #  3. All advertising materials mentioning features or use of this software
  17. #     must display the following acknowledgement:
  18. #     This product includes software developed by Torsten Poulin.
  19. #  4. The name of Torsten Poulin may not be used to endorse or
  20. #     promote products derived from this software without specific prior
  21. #     written permission.
  22. #
  23. #  This software is provided by Torsten Poulin "as is" and any
  24. #  express or implied warranties, including, but not limited to, the
  25. #  implied warranties of merchantability and fitness for a particular
  26. #  purpose are disclaimed.  In no event shall Torsten Poulin be liable
  27. #  for any direct, indirect, incidental, special, exemplary, or
  28. #  consequential damages (including, but not limited to, procurement
  29. #  of substitute goods or services; loss of use, data, or profits; or
  30. #  business interruption) however caused and on any theory of
  31. #  liability, whether in contract, strict liability, or tort
  32. #  (including negligence or otherwise) arising in any way out of the
  33. #  use of this software, even if advised of the possibility of such
  34. #  damage.
  35.  
  36.  
  37. include io.h
  38. include fsplit.h
  39.  
  40. program fsplit
  41.    character*LINELEN fname
  42.    integer what
  43.    integer openf, getlin
  44.  
  45.    call banner
  46.    call putlin(STDOUT, 'Enter name of FORTRAN source file:', 34)
  47.    what = getlin(STDIN, fname, LINELEN)
  48.  
  49.    if (what == OK & fname != ' ')
  50.    {
  51.       if (openf(FORTRAN, fname, MOLD) != OK)
  52.          call putlin(STDOUT, "Couldn't open file", 18)
  53.       else
  54.       {
  55.          call handle(FORTRAN)
  56.          call closef(FORTRAN)
  57.       }
  58.    }
  59.    else
  60.       call putlin(STDOUT, 'Aborted!', 8)
  61. end
  62.  
  63.  
  64. subroutine handle(funit)
  65.    integer funit, typ
  66.    character*LINELEN line, blknam, name
  67.    integer openf, lintyp, opnout
  68.    logical error, inblck, wrote
  69.  
  70.    error = .false.; inblck = .false.; wrote = .false.
  71.  
  72.    if (openf(SCRATCH, '', MSCRATCH) != OK) error = .true.
  73.  
  74.    if (!error)
  75.    {
  76.       call putlin(STDOUT, 'Writing', 7)
  77.  
  78.       repeat
  79.       {
  80.          typ = lintyp(funit, line, blknam)
  81.          if (typ != EOF)
  82.          {
  83.             call putlin(SCRATCH, line, LINELEN)
  84.             wrote = .true.
  85.          }
  86.  
  87.          if (typ == BLOCK)
  88.          {
  89.             if (!inblck)
  90.             {
  91.                inblck = .true.
  92.                name = blknam
  93.             }
  94.          }
  95.          else if ((typ == ENDSTAT | typ == EOF) & wrote)
  96.          {
  97.             if (!inblck) name = PRGNAME
  98.             inblck = .false.
  99.             if (opnout(OUTPUT, name) == OK)
  100.             {
  101.                rewind SCRATCH
  102.                call copy(SCRATCH, OUTPUT)
  103.                call closef(OUTPUT)
  104.                call closef(SCRATCH)
  105.                if (openf(SCRATCH, '', MSCRATCH) != OK)
  106.                {
  107.                   error = .true.
  108.                   typ = EOF  # get us out of here...
  109.                }
  110.                wrote = .false.
  111.             }
  112.          }
  113.       } until (typ == EOF)
  114.  
  115.       if (!error)
  116.       {
  117.          call closef(SCRATCH)
  118.          call putlin(STDOUT, 'Done.', 5)
  119.       }
  120.    }
  121.  
  122.    if (error)
  123.       call putlin(STDOUT, "Couldn't open temporary file", 28)
  124. end
  125.  
  126.  
  127. integer function lintyp(funit, line, blknam)
  128.    integer funit
  129.    character*LINELEN line, blknam, l
  130.    integer where, res
  131.    integer getlin
  132.    logical getnam, iscmnt
  133.  
  134.    res = getlin(funit, line, LINELEN)
  135.    if (res != OK) return (EOF) # EOF is ok for errors
  136.    
  137.    if (iscmnt(line)) return (OTHER)
  138.  
  139.    call strip(line, l)
  140.  
  141.    where = index(l, 'subroutine')
  142.    if (where > 0)
  143.    {
  144.       if (!getnam(l, where + 10, blknam)) blknam = SUBNAME
  145.       return (BLOCK)
  146.    }
  147.  
  148.    where = index(l, 'function')
  149.    if (where > 0)
  150.    {
  151.       if (!getnam(l, where + 8, blknam)) blknam = FUNNAME
  152.       return (BLOCK)
  153.    }
  154.  
  155.    where = index(l, 'program')
  156.    if (where > 0)
  157.    {
  158.       if (!getnam(l, where + 7, blknam)) blknam = PRGNAME
  159.       return (BLOCK)
  160.    }
  161.  
  162.    where = index(l, 'blockdata')
  163.    if (where > 0)
  164.    {
  165.       if (!getnam(l, where + 9, blknam)) blknam = BLKNAME
  166.       return (BLOCK)
  167.    }
  168.  
  169.    if (l == 'end') return (ENDSTAT)
  170.  
  171.    return (OTHER)
  172. end
  173.  
  174.  
  175. # Is line a comment?
  176.  
  177. logical function iscmnt(line)
  178.    character line*LINELEN, ch
  179.  
  180.    ch = line(1:1)
  181.    return (ch == 'c' | ch == 'C' | ch == '*')
  182. end
  183.  
  184.  
  185. logical function getnam(line, offset, name)
  186.     character*LINELEN line, name
  187.     integer offset, i
  188.     character c
  189.     logical islow, isdig
  190.  
  191.     name = ' '
  192.  
  193.     i = 1
  194.     while (i <= 6 & offset <= LINELEN)
  195.     {
  196.        c = line(offset:offset)
  197.  
  198.        if (!(islow(c) | isdig(c))) break
  199.        name(i:i) = c
  200.  
  201.        i = i + 1; offset = offset + 1
  202.     }
  203.  
  204.     return (i > 1)
  205. end
  206.  
  207.  
  208. # Remove all blanks and any initial digits (i.e., statement
  209. # labels) from 'line' and return the resulting string
  210. # in 'noblnk'.
  211. #
  212. # Comments introduced by an exclamation mark
  213. # are stripped. All letters are converted to lowercase.
  214. #
  215. # The resulting string, 'noblnk', is padded with blanks
  216. # at the end.
  217.  
  218. subroutine strip(line, noblnk)
  219.    character*LINELEN line, noblnk
  220.    character c
  221.    integer i, j
  222.    character tolow
  223.    logical isdig
  224.  
  225.    i = 1; j = 1
  226.  
  227.    # Skip any initial blanks or digits
  228.  
  229.    while (i <= LINELEN)
  230.    {
  231.       c = line(i:i)
  232.       if (c != ' ' & c != TAB & !isdig(c)) break
  233.       i = i + 1
  234.    }
  235.  
  236.    # Process the rest of the line
  237.  
  238.    noblnk = ' '
  239.    while (i <= LINELEN)
  240.    {
  241.       c = line(i:i)
  242.       if (c == '!') break  # Nothing interesting after a bang!
  243.       else if (c != ' ' & c != TAB)
  244.       {
  245.          noblnk(j:j) = tolow(c)
  246.          j = j + 1
  247.       }
  248.       i = i + 1
  249.    }
  250. end
  251.  
  252.  
  253. # Copy lines from file 'from' to file 'to'
  254.  
  255. subroutine copy(from, to)
  256.    integer from, to
  257.    character*LINELEN line
  258.    integer getlin
  259.  
  260.    while (getlin(from, line, LINELEN) == OK)
  261.       call putlin(to, line, LINELEN)
  262. end
  263.  
  264.  
  265. # Attempt to open the output file
  266.  
  267. integer function opnout(funit, fname)
  268.    integer funit
  269.    character*LINELEN fname, name
  270.    integer i, num
  271.    integer openf
  272.  
  273.    # Find the end of 'name'
  274.  
  275.    name = fname
  276.    for (i = 1; i <= MAXNAME; i = i + 1)
  277.       if (name(i:i) == ' ' | name(i:i) == TAB)
  278.          break
  279.  
  280.    # Append extension and attempt to open it
  281.  
  282.    name(i:i+1) = '.f'
  283.    if (openf(funit, name, MNEW) == OK)
  284.    {
  285.       call putlin(STDOUT, name, LINELEN)
  286.       return (OK)
  287.    }
  288.  
  289.    # Blast! Add a number and retry...
  290.  
  291.    for (num = 1; num < 100; num = num + 1)
  292.    {
  293.       write (name(i:i+1), '(I2.2)') num
  294.       name(i+2:i+3) = '.f'
  295.       if (openf(funit, name, MNEW) == OK)
  296.       {
  297.          # Lo! and behold
  298.          call putlin(STDOUT, name, LINELEN)
  299.          return (OK)
  300.       }
  301.    }
  302.  
  303.    call putlin(STDOUT, "Ran out of output file names", 28)
  304.    return (ERR)
  305. end
  306.  
  307.  
  308. # Print the banner
  309.  
  310. subroutine banner
  311.    call putlin(STDOUT, 'This is FSPLIT, Version 1.0 [25-Jul-94].', 40)
  312.    call putlin(STDOUT,
  313.       'Copyright (C) 1994 Torsten Poulin. Email: <torsten@diku.dk>', 59)
  314. end
  315.